home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / sptmbr11.lha / clcs / condition-definitions.lisp next >
Lisp/Scheme  |  1992-06-04  |  13KB  |  388 lines
  1. ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*-
  2.  
  3. (IN-PACKAGE "CONDITIONS")
  4.  
  5. (eval-when (compile load eval)
  6. (pushnew #+(or clos pcl) :clos-conditions #-(or clos pcl) :defstruct-conditions
  7.      *features*)
  8. )
  9.  
  10. (eval-when (compile load eval)
  11. (when (and (member :clos-conditions *features*)
  12.        (member :defstruct-conditions *features*))
  13.   (dolist (sym '(simple-condition-format-string simple-condition-format-arguments
  14.          type-error-datum type-error-expected-type
  15.          case-failure-name case-failure-possibilities
  16.          stream-error-stream file-error-pathname package-error-package
  17.          cell-error-name arithmetic-error-operation
  18.          internal-error-function-name))
  19.     (when (fboundp sym) (fmakunbound sym)))
  20.   (setq *features* (remove :defstruct-conditions *features*)))
  21. )
  22.  
  23. (DEFINE-CONDITION WARNING (CONDITION)
  24.   ())
  25.  
  26. (DEFINE-CONDITION SERIOUS-CONDITION (CONDITION)
  27.   ())
  28.  
  29. (DEFINE-CONDITION lisp:ERROR (SERIOUS-CONDITION)
  30.   ())
  31.  
  32. (DEFUN SIMPLE-CONDITION-PRINTER (CONDITION STREAM)
  33.   (APPLY #'FORMAT STREAM (SIMPLE-CONDITION-FORMAT-STRING    CONDITION)
  34.               (SIMPLE-CONDITION-FORMAT-ARGUMENTS CONDITION)))
  35.  
  36. (DEFINE-CONDITION SIMPLE-CONDITION (CONDITION)
  37.   #-(or clos pcl)
  38.   (FORMAT-STRING (FORMAT-ARGUMENTS '()))
  39.   #+(or clos pcl)
  40.   ((FORMAT-STRING :type string
  41.           :initarg :FORMAT-STRING
  42.           :reader SIMPLE-CONDITION-FORMAT-STRING)
  43.    (FORMAT-ARGUMENTS :initarg :FORMAT-ARGUMENTS
  44.              :reader SIMPLE-CONDITION-FORMAT-ARGUMENTS
  45.              :initform '()))
  46.   #-(or clos pcl)(:CONC-NAME %%SIMPLE-CONDITION-)
  47.   (:REPORT SIMPLE-CONDITION-PRINTER))
  48.  
  49. (DEFINE-CONDITION SIMPLE-WARNING (#+(or clos pcl) SIMPLE-CONDITION WARNING)
  50.   #-(or clos pcl)
  51.   (FORMAT-STRING (FORMAT-ARGUMENTS '()))
  52.   #+(or clos pcl)
  53.   ()
  54.   #-(or clos pcl)(:CONC-NAME %%SIMPLE-WARNING-)
  55.   #-(or clos pcl)(:REPORT SIMPLE-CONDITION-PRINTER))
  56.  
  57. (DEFINE-CONDITION SIMPLE-ERROR (#+(or clos pcl) SIMPLE-CONDITION lisp:ERROR)
  58.   #-(or clos pcl)
  59.   (FORMAT-STRING (FORMAT-ARGUMENTS '()))
  60.   #+(or clos pcl)
  61.   ()
  62.   #-(or clos pcl)(:CONC-NAME %%SIMPLE-ERROR-)
  63.   #-(or clos pcl)(:REPORT SIMPLE-CONDITION-PRINTER))
  64.  
  65. (DEFINE-CONDITION STORAGE-CONDITION (SERIOUS-CONDITION) ())
  66.  
  67. (DEFINE-CONDITION STACK-OVERFLOW    (STORAGE-CONDITION) ())
  68.  
  69. (DEFINE-CONDITION STORAGE-EXHAUSTED (STORAGE-CONDITION) ())
  70.  
  71. (DEFINE-CONDITION TYPE-ERROR (lisp:ERROR)
  72.   #-(or clos pcl)
  73.   (DATUM EXPECTED-TYPE)
  74.   #+(or clos pcl)
  75.   ((DATUM :initarg :DATUM
  76.       :reader TYPE-ERROR-DATUM)
  77.    (EXPECTED-TYPE :initarg :EXPECTED-TYPE
  78.           :reader TYPE-ERROR-EXPECTED-TYPE))
  79.   (:report
  80.     (lambda (condition stream)
  81.       (format stream "~S is not of type ~S."
  82.           (TYPE-ERROR-DATUM CONDITION)
  83.           (TYPE-ERROR-EXPECTED-TYPE CONDITION)))))
  84.  
  85. (DEFINE-CONDITION SIMPLE-TYPE-ERROR (#+(or clos pcl) SIMPLE-CONDITION TYPE-ERROR)
  86.   #-(or clos pcl)
  87.   (FORMAT-STRING (FORMAT-ARGUMENTS '()))
  88.   #+(or clos pcl)
  89.   ()
  90.   #-(or clos pcl)(:CONC-NAME %%SIMPLE-TYPE-ERROR-)
  91.   #-(or clos pcl)(:REPORT SIMPLE-CONDITION-PRINTER))
  92.  
  93. (DEFINE-CONDITION CASE-FAILURE (TYPE-ERROR)
  94.  #-(or clos pcl)
  95.  (NAME POSSIBILITIES)
  96.  #+(or clos pcl)
  97.  ((NAME :initarg :NAME
  98.     :reader CASE-FAILURE-NAME)
  99.   (POSSIBILITIES :initarg :POSSIBILITIES
  100.          :reader CASE-FAILURE-POSSIBILITIES))
  101.   (:REPORT
  102.     (LAMBDA (CONDITION STREAM)
  103.       (FORMAT STREAM "~S fell through ~S expression.~%Wanted one of ~:S."
  104.           (TYPE-ERROR-DATUM CONDITION)
  105.           (CASE-FAILURE-NAME CONDITION)
  106.           (CASE-FAILURE-POSSIBILITIES CONDITION)))))
  107.  
  108. (DEFINE-CONDITION PROGRAM-ERROR (lisp:ERROR)
  109.   ())
  110.  
  111. (DEFINE-CONDITION CONTROL-ERROR (lisp:ERROR)
  112.   ())
  113.  
  114. (DEFINE-CONDITION STREAM-ERROR (lisp:ERROR)
  115.   #-(or clos pcl)
  116.   (STREAM)
  117.   #+(or clos pcl)
  118.   ((STREAM :initarg :STREAM
  119.        :reader STREAM-ERROR-STREAM)))
  120.  
  121. (DEFINE-CONDITION END-OF-FILE (STREAM-ERROR)
  122.   ()
  123.   (:REPORT (LAMBDA (CONDITION STREAM)
  124.          (FORMAT STREAM "Unexpected end of file on ~S."
  125.              (STREAM-ERROR-STREAM CONDITION)))))
  126.  
  127. (DEFINE-CONDITION FILE-ERROR (lisp:ERROR)
  128.   #-(or clos pcl)
  129.   (PATHNAME)
  130.   #+(or clos pcl)
  131.   ((PATHNAME :initarg :PATHNAME
  132.          :reader FILE-ERROR-PATHNAME)))
  133.  
  134. (DEFINE-CONDITION PACKAGE-ERROR (lisp:ERROR)
  135.   #-(or clos pcl)
  136.   (PACKAGE)
  137.   #+(or clos pcl)
  138.   ((PACKAGE :initarg :PACKAGE
  139.         :reader PACKAGE-ERROR-PACKAGE)))
  140.  
  141. (DEFINE-CONDITION CELL-ERROR (lisp:ERROR)
  142.   #-(or clos pcl)
  143.   (NAME)
  144.   #+(or clos pcl)
  145.   ((NAME :initarg :NAME
  146.      :reader CELL-ERROR-NAME)))
  147.  
  148. (DEFINE-CONDITION UNBOUND-VARIABLE (CELL-ERROR)
  149.   ()
  150.   (:REPORT (LAMBDA (CONDITION STREAM)
  151.          (FORMAT STREAM "The variable ~S is unbound."
  152.              (CELL-ERROR-NAME CONDITION)))))
  153.   
  154. (DEFINE-CONDITION UNDEFINED-FUNCTION (CELL-ERROR)
  155.   ()
  156.   (:REPORT (LAMBDA (CONDITION STREAM)
  157.          (FORMAT STREAM "The function ~S is undefined."
  158.              (CELL-ERROR-NAME CONDITION)))))
  159.  
  160. (DEFINE-CONDITION ARITHMETIC-ERROR (lisp:ERROR)
  161.   #-(or clos pcl)
  162.   (OPERATION OPERANDS)
  163.   #+(or clos pcl)
  164.   ((OPERATION :initarg :OPERATION
  165.           :reader ARITHMETIC-ERROR-OPERATION)))
  166.  
  167. (DEFINE-CONDITION DIVISION-BY-ZERO         (ARITHMETIC-ERROR)
  168.   ())
  169.  
  170. (DEFINE-CONDITION FLOATING-POINT-OVERFLOW  (ARITHMETIC-ERROR)
  171.   ())
  172.  
  173. (DEFINE-CONDITION FLOATING-POINT-UNDERFLOW (ARITHMETIC-ERROR)
  174.   ())
  175.  
  176. (DEFINE-CONDITION ABORT-FAILURE (CONTROL-ERROR) ()
  177.   (:REPORT "Abort failed."))
  178.  
  179. #+kcl
  180. (progn
  181. (define-condition internal-error (lisp:error)
  182.   #-(or clos pcl)
  183.   ((function-name nil))
  184.   #+(or clos pcl)
  185.   ((function-name :initarg :function-name
  186.           :reader internal-error-function-name
  187.           :initform 'nil))
  188.   (:report (lambda (condition stream)
  189.          (when (internal-error-function-name condition)
  190.            (format stream "Error in ~S [or a callee]: "
  191.                (internal-error-function-name condition)))
  192.          #+(or clos pcl)(call-next-method))))
  193.  
  194. (defun internal-simple-error-printer (condition stream)
  195.   (when (internal-error-function-name condition)
  196.     (format stream "Error in ~S [or a callee]: "
  197.         (internal-error-function-name condition)))
  198.   (apply #'format stream (simple-condition-format-string    condition)
  199.               (simple-condition-format-arguments condition)))
  200.  
  201. (define-condition internal-simple-error 
  202.     (internal-error #+(or clos pcl) simple-condition)
  203.   #-(or clos pcl)
  204.   ((function-name nil) format-string (format-arguments '()))
  205.   #+(or clos pcl)
  206.   ()
  207.   #-(or clos pcl)(:conc-name %%internal-simple-error-)
  208.   (:report internal-simple-error-printer))
  209.  
  210. (define-condition internal-type-error 
  211.     (#+(or clos pcl) internal-error type-error)
  212.   #-(or clos pcl)
  213.   ((function-name nil))
  214.   #+(or clos pcl)
  215.   ()
  216.   #-(or clos pcl)(:conc-name %%internal-type-error-)
  217.   #-(or clos pcl)(:report (lambda (condition stream)
  218.                 (when (internal-error-function-name condition)
  219.                   (format stream "Error in ~S [or a callee]: "
  220.                       (internal-error-function-name condition)))
  221.                 (format stream "~S is not of type ~S."
  222.                     (type-error-datum condition)
  223.                     (type-error-expected-type condition)))))
  224.  
  225. (define-condition internal-simple-program-error 
  226.     (#+(or clos pcl) internal-simple-error program-error)
  227.   #-(or clos pcl)
  228.   ((function-name nil) format-string (format-arguments '()))
  229.   #+(or clos pcl)
  230.   ()
  231.   #-(or clos pcl)(:conc-name %%internal-simple-program-error-)
  232.   #-(or clos pcl)(:report internal-simple-error-printer))
  233.  
  234. (define-condition internal-simple-control-error 
  235.     (#+(or clos pcl) internal-simple-error control-error)
  236.   #-(or clos pcl)
  237.   ((function-name nil) format-string (format-arguments '()))
  238.   #+(or clos pcl)
  239.   ()
  240.   #-(or clos pcl)(:conc-name %%internal-simple-control-error-)
  241.   #-(or clos pcl)(:report internal-simple-error-printer))
  242.  
  243. (define-condition internal-unbound-variable 
  244.     (#+(or clos pcl) internal-error unbound-variable)
  245.   #-(or clos pcl)
  246.   ((function-name nil))
  247.   #+(or clos pcl)
  248.   ()
  249.   #-(or clos pcl)(:conc-name %%internal-unbound-variable-)
  250.   #-(or clos pcl)(:REPORT (LAMBDA (CONDITION STREAM)
  251.                 (when (internal-error-function-name condition)
  252.                   (format stream "Error in ~S [or a callee]: "
  253.                       (internal-error-function-name condition)))
  254.                 (FORMAT STREAM "The variable ~S is unbound."
  255.                     (CELL-ERROR-NAME CONDITION)))))
  256.  
  257. (define-condition internal-undefined-function 
  258.     (#+(or clos pcl) internal-error undefined-function)
  259.   #-(or clos pcl)
  260.   ((function-name nil))
  261.   #+(or clos pcl)
  262.   ()
  263.   #-(or clos pcl)(:conc-name %%internal-undefined-function-)
  264.   #-(or clos pcl)(:REPORT (LAMBDA (CONDITION STREAM)
  265.                 (when (internal-error-function-name condition)
  266.                   (format stream "Error in ~S [or a callee]: "
  267.                       (internal-error-function-name condition)))
  268.                 (FORMAT STREAM "The function ~S is undefined."
  269.                     (CELL-ERROR-NAME CONDITION)))))
  270.  
  271. (define-condition internal-end-of-file 
  272.     (#+(or clos pcl) internal-error end-of-file)
  273.   #-(or clos pcl)
  274.   ((function-name nil))
  275.   #+(or clos pcl)
  276.   ()
  277.   #-(or clos pcl)(:conc-name %%internal-end-of-file-)
  278.   #-(or clos pcl)(:REPORT (LAMBDA (CONDITION STREAM)
  279.                 (when (internal-error-function-name condition)
  280.                   (format stream "Error in ~S [or a callee]: "
  281.                       (internal-error-function-name condition)))
  282.                 (FORMAT STREAM "Unexpected end of file on ~S."
  283.                     (STREAM-ERROR-STREAM CONDITION)))))
  284.  
  285. (define-condition internal-simple-file-error
  286.     (#+(or clos pcl) internal-simple-error file-error)
  287.   #-(or clos pcl)
  288.   ((function-name nil) format-string (format-arguments '()))
  289.   #+(or clos pcl)
  290.   ()
  291.   #-(or clos pcl)(:conc-name %%internal-simple-file-error-)
  292.   #-(or clos pcl)(:report internal-simple-error-printer))
  293.  
  294. (define-condition internal-simple-stream-error 
  295.     (#+(or clos pcl) internal-simple-error stream-error)
  296.   #-(or clos pcl)
  297.   ((function-name nil) format-string (format-arguments '()))
  298.   #+(or clos pcl)
  299.   ()
  300.   #-(or clos pcl)(:conc-name %%internal-simple-stream-error-)
  301.   #-(or clos pcl)(:report internal-simple-error-printer))
  302.  
  303. #-(or pcl clos)
  304. (defun internal-error-function-name (condition)
  305.   (etypecase condition
  306.     (internal-error                
  307.      (%%internal-error-function-name condition))
  308.     (internal-simple-error         
  309.      (%%internal-simple-error-function-name condition))
  310.     (internal-type-error 
  311.      (%%internal-type-error-function-name condition))
  312.     (internal-simple-program-error
  313.      (%%internal-simple-program-error-function-name condition))
  314.     (internal-simple-control-error
  315.      (%%internal-simple-control-error-function-name condition))
  316.     (internal-unbound-variable  
  317.      (%%internal-unbound-variable-function-name condition))
  318.     (internal-undefined-function 
  319.      (%%internal-undefined-function-function-name condition))
  320.     (internal-end-of-file        
  321.      (%%internal-end-of-file-function-name condition))
  322.     (internal-simple-file-error  
  323.      (%%internal-simple-file-error-function-name condition))
  324.     (internal-simple-stream-error 
  325.      (%%internal-simple-stream-error-function-name condition))))
  326. )
  327.  
  328. #-(or clos pcl)
  329. (progn
  330.  
  331. (DEFUN SIMPLE-CONDITION-FORMAT-STRING (CONDITION)
  332.   (ETYPECASE CONDITION
  333.     (SIMPLE-CONDITION  (%%SIMPLE-CONDITION-FORMAT-STRING  CONDITION))
  334.     (SIMPLE-WARNING    (%%SIMPLE-WARNING-FORMAT-STRING    CONDITION))
  335.     (SIMPLE-TYPE-ERROR (%%SIMPLE-TYPE-ERROR-FORMAT-STRING CONDITION))
  336.     (SIMPLE-ERROR      (%%SIMPLE-ERROR-FORMAT-STRING      CONDITION))
  337.     #+kcl(internal-simple-error
  338.       (%%internal-simple-error-format-string condition))
  339.     #+kcl(internal-simple-program-error
  340.       (%%internal-simple-program-error-format-string condition))
  341.     #+kcl(internal-simple-control-error
  342.       (%%internal-simple-control-error-format-string condition))
  343.     #+kcl(internal-simple-file-error
  344.       (%%internal-simple-file-error-format-string condition))
  345.     #+kcl(internal-simple-stream-error
  346.       (%%internal-simple-stream-error-format-string condition))))
  347.  
  348. (DEFUN SIMPLE-CONDITION-FORMAT-ARGUMENTS (CONDITION)
  349.   (ETYPECASE CONDITION
  350.     (SIMPLE-CONDITION  (%%SIMPLE-CONDITION-FORMAT-ARGUMENTS  CONDITION))
  351.     (SIMPLE-WARNING    (%%SIMPLE-WARNING-FORMAT-ARGUMENTS    CONDITION))
  352.     (SIMPLE-TYPE-ERROR (%%SIMPLE-TYPE-ERROR-FORMAT-ARGUMENTS CONDITION))
  353.     (SIMPLE-ERROR      (%%SIMPLE-ERROR-FORMAT-ARGUMENTS      CONDITION))
  354.     #+kcl(internal-simple-error
  355.       (%%internal-simple-error-format-arguments condition))
  356.     #+kcl(internal-simple-program-error
  357.       (%%internal-simple-program-error-format-arguments condition))
  358.     #+kcl(internal-simple-control-error
  359.       (%%internal-simple-control-error-format-arguments condition))
  360.     #+kcl(internal-simple-file-error
  361.       (%%internal-simple-file-error-format-arguments condition))
  362.     #+kcl(internal-simple-stream-error
  363.       (%%internal-simple-stream-error-format-arguments condition))))
  364.  
  365. (defun simple-condition-class-p (type)
  366.   (member type '(SIMPLE-CONDITION SIMPLE-WARNING SIMPLE-TYPE-ERROR SIMPLE-ERROR
  367.          #+kcl internal-simple-error
  368.          #+kcl internal-simple-program-error
  369.          #+kcl internal-simple-control-error
  370.          #+kcl internal-simple-file-error
  371.          #+kcl internal-simple-stream-error)))
  372. )
  373.  
  374. #+(or clos pcl)
  375. (progn
  376. (defvar *simple-condition-class* (find-class 'simple-condition))
  377.  
  378. (defun simple-condition-class-p (TYPE)
  379.   (when (symbolp TYPE)
  380.     (setq TYPE (find-class TYPE)))
  381.   (and (typep TYPE 'standard-class)
  382.        (member *simple-condition-class* 
  383.            (#+pcl pcl::class-precedence-list
  384.         #-pcl clos::class-precedence-list
  385.           type))))
  386. )
  387.  
  388.